home *** CD-ROM | disk | FTP | other *** search
/ Clickx 115 / Clickx 115.iso / software / tools / windows / tails-i386-0.16.iso / live / filesystem.squashfs / usr / share / uim / lib / srfi-0.scm < prev    next >
Encoding:
Text File  |  2010-11-07  |  3.4 KB  |  83 lines
  1. ;;  Filename : srfi-0.scm
  2. ;;  About    : SRFI-0 Feature-based conditional expansion construct
  3. ;;
  4. ;;  Copyright (c) 2007-2008 SigScheme Project <uim-en AT googlegroups.com>
  5. ;;
  6. ;;  All rights reserved.
  7. ;;
  8. ;;  Redistribution and use in source and binary forms, with or without
  9. ;;  modification, are permitted provided that the following conditions
  10. ;;  are met:
  11. ;;
  12. ;;  1. Redistributions of source code must retain the above copyright
  13. ;;     notice, this list of conditions and the following disclaimer.
  14. ;;  2. Redistributions in binary form must reproduce the above copyright
  15. ;;     notice, this list of conditions and the following disclaimer in the
  16. ;;     documentation and/or other materials provided with the distribution.
  17. ;;  3. Neither the name of authors nor the names of its contributors
  18. ;;     may be used to endorse or promote products derived from this software
  19. ;;     without specific prior written permission.
  20. ;;
  21. ;;  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS
  22. ;;  IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
  23. ;;  THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
  24. ;;  PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
  25. ;;  CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
  26. ;;  EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
  27. ;;  PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
  28. ;;  PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
  29. ;;  LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
  30. ;;  NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
  31. ;;  SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  32.  
  33.  
  34. (require-extension (srfi 23))
  35.  
  36. (define-macro %cond-expand-dummy
  37.   (lambda () #t))
  38.  
  39. (define %cond-expand-feature?
  40.   (lambda (feature-exp)
  41.     (cond
  42.      ((symbol? feature-exp)
  43.       (or (eq? feature-exp 'else)
  44.           (provided? (symbol->string feature-exp))))
  45.      ((pair? feature-exp)
  46.       (let ((directive (car feature-exp))
  47.             (args (cdr feature-exp)))
  48.       (case directive
  49.         ((and)
  50.          ;;(every %cond-expand-feature? args))
  51.          (not (memq #f (map %cond-expand-feature? args))))
  52.         ((or)
  53.          ;;(any %cond-expand-feature? args))
  54.          (not (not (memq #t (map %cond-expand-feature? args)))))
  55.         ((not)
  56.          (if (not (null? (cdr args)))
  57.              (error "invalid feature expression"))
  58.          (not (%cond-expand-feature? (car args))))
  59.         (else
  60.          (error "invalid feature expression"))))))))
  61.  
  62. (define-macro cond-expand
  63.   (lambda clauses
  64.     (if (null? clauses)
  65.         (error "unfulfilled cond-expand")
  66. ;;        (let ((clause (find (lambda (clause)
  67. ;;                              (%cond-expand-feature? (car clause)))
  68. ;;                            clauses)))
  69.         (let ((clause (let rec ((rest clauses))
  70.                           (cond
  71.                            ((null? rest)
  72.                             #f)
  73.                            ((%cond-expand-feature? (caar rest))
  74.                             (car rest))
  75.                            (else
  76.                             (rec (cdr rest)))))))
  77.           (if clause
  78.               `(begin
  79.                  ;; raise error if cond-expand is placed in non-toplevel
  80.                  (define-macro %cond-expand-dummy (lambda () #t))
  81.                  . ,(cdr clause))
  82.               (error "unfulfilled cond-expand"))))))
  83.